home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / fs.t < prev    next >
Text File  |  1988-05-02  |  18KB  |  518 lines
  1. (herald fs (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26.  
  27. ;;;; File systems and filename translation
  28.  
  29.  
  30. ;;; ---------- File system types:
  31.  
  32. ;;; Convert symbol pname to case preferred by file system types.
  33.  
  34. (define-operation (->preferred-case fstype string)
  35.   (string-downcase string))             ; lower
  36.  
  37. (define-operation (special-symbols fstype) '(\/\/ \/ \. \.. \~))
  38.  
  39.  
  40. ;;; Called if logical name spec was a string.
  41.  
  42. (define-operation (massage-dir-string fstype dir)
  43.   (string-append dir "/"))
  44.  
  45. (define-operation (massage-dir-pair fstype dir)
  46.   (with-buffers ((buf))
  47.     (let* ((1st  (car dir))
  48.            (rest (cond ((memq? (car dir) (special-symbols fstype))
  49.                         (display 1st buf)
  50.                         (cdr dir))
  51.                        (else dir))))
  52.       (iterate loop ((l rest))
  53.         (cond ((null? l)
  54.                (buffer->string buf))
  55.               (else
  56.                (display (->preferred-case fstype (symbol->string (car l))) buf)
  57.                (write-char buf #\/)
  58.                (loop (cdr l))))))))
  59.  
  60. ;;; Called if ln spec was a symbol not in logical name table.
  61.  
  62. (define-operation (massage-logical-name fstype ln)
  63.   (string-append (->preferred-case fstype (symbol->string ln)) "/"))
  64.  
  65. (define-operation (massage-gen-part fstype gen)
  66.   (ignore fstype gen)
  67.   "")
  68.  
  69. (define-operation (query-fs-names fstype fs)
  70.   (read-fs-names-from 
  71.    (make-filename fs 
  72.                   (the-t-system-directory) 
  73.                   'localfs 
  74.                   't)))
  75.  
  76. ;;; Utility for QUERY-FS-NAMES
  77.  
  78. (define (read-fs-names-from filename)
  79.   (with-open-ports ((port (maybe-open filename 'in)))
  80.     (cond ((and port (graphic? (peekc port)))
  81.            (let ((probe (read port)))
  82.              (cond ((pair? probe) probe)
  83.                    (else (list probe)))))
  84.           (else nil))))     ; Assume () = false
  85.  
  86. ;;; Initialize the local file system names.
  87.  
  88. (define (initialize-local-fs)
  89.   (let ((fs (make-local-fs)))
  90.     (set (local-fs) fs)
  91.     (walk (lambda (name)
  92.             (set-fs-name fs name))
  93.           (query-fs-names (fs-type fs) fs))
  94.     fs))
  95.  
  96. ;;; Parse a filespec string.
  97.  
  98. ;++ These are need for parsing strings
  99.  
  100. (define-operation (parse-filespec fstype fs string)
  101.   (make-filename fs nil string nil))
  102.  
  103. ;;; FS type table (?)
  104.  
  105. (define fs-type-table (make-table 'fs-type-table))
  106.  
  107. ;;; Anonymous 
  108.  
  109. (define anonymous-fs?
  110.   (object (lambda (fs) (eq? (fs-type fs) anonymous-fs?))
  111.     ((parse-filespec self fs string)
  112.      (ignore fs)
  113.      (string->filename string #\/ #\.))
  114.     ((print self port)
  115.      (format port "#{File-system-type~_Anonymous}"))))
  116.  
  117. ;;; Aegis
  118.  
  119. (define aegis-fs?
  120.   (let ((specials '(\/\/ \/ \. \\ \~)))
  121.     (object (lambda (fs) (eq? (fs-type fs) aegis-fs?))
  122.       ((special-symbols self) specials)
  123.       ((massage-logical-name self ln)
  124.        (let ((ln-string (string-downcase (symbol->string ln))))
  125.          (cond ((memq? ln specials)
  126.                 ln-string)
  127.                (else 
  128.                 (string-append "~" ln-string "/")))))
  129.       ((parse-filespec self fs string)
  130.        (ignore fs)
  131.        (string->filename string #\/ #\.)) 
  132.       ((print self port)
  133.        (format port "#{File-system-type~_AEGIS}")))))
  134.  
  135. (define (make-aegis-fs names)
  136.   (make-fs aegis-fs? names))
  137.  
  138. ;;; UNIX
  139.  
  140. (define unix-fs?
  141.   (let ((specials '(\/\/ \/ \. \.. \$)))
  142.     (object (lambda (fs) (eq? (fs-type fs) unix-fs?))
  143.       ((special-symbols self) specials)
  144.       ((massage-logical-name self ln)
  145.        (let ((ln-string (symbol->string ln)))
  146.          (cond ((memq? ln specials)
  147.                 ln-string)
  148.                (else 
  149.                 (string-append "$" (string-upcase ln-string) "/")))))
  150.       ((query-fs-names self fs)
  151.        (or (read-fs-names-from (make-filename fs nil "/etc/sysname" nil))
  152.            (read-fs-names-from
  153.             (make-filename fs
  154.                            (the-T-system-directory)
  155.                           'localfs 
  156.                           't))))
  157.       ((parse-filespec self fs string)
  158.        (ignore fs)
  159.        (string->filename string #\/ #\.)) 
  160.       ((print self port)
  161.        (format port "#{File-system-type~_UNIX}")))))
  162.  
  163. (define (make-unix-fs names)
  164.   (make-fs unix-fs? names))
  165.  
  166. ;;; VMS
  167.  
  168. (define vms-fs?
  169.   (object (lambda (fs) (eq? (fs-type fs) vms-fs?))
  170.     ((massage-dir-pair fstype dir)
  171.      (with-buffers ((buf))
  172.        (write-char buf #\[)
  173.        (display (car dir) buf)
  174.        (iterate loop ((l (cdr dir)))
  175.          (cond ((null? l)
  176.                 (write-char buf #\])
  177.                 (buffer->string buf))
  178.                (else
  179.                 (write-char buf #\.)
  180.                 (display (car l) buf)
  181.                 (loop (cdr l)))))))
  182.     ((massage-logical-name self ln)
  183.      (string-append (symbol->string ln) ":"))
  184.     ((->preferred-case self string) string)
  185.     ((massage-gen-part self gen)
  186.      (cond ((fixnum? gen) (format nil ".~S" gen))
  187.            ((eq? gen 'newest) ".0")
  188.            (else nil)))
  189.     ((parse-filespec self fs string)
  190.      (ignore fs)
  191.      (string->filename string #\/ #\.)) 
  192.     ((print self port)
  193.      (format port "#{File-system-type~_VMS}"))))
  194.  
  195. (define (make-vms-fs names)
  196.   (make-fs vms-fs? names))
  197.  
  198. ;;; ---------- File systems:
  199.  
  200. ;;; File systems are instantiations of file system types.
  201.  
  202. (define-operation (fs-type fs))         ; Return an fs-type object for the fs
  203. (define-operation (fs-name fs))         ; Return a symbol naming the fs
  204.  
  205. (define-settable-operation (logical-name fs ln))
  206. (define set-logical-name (setter logical-name))
  207.  
  208. (define-settable-operation (fs-maybe-open-proc fs))
  209. (define set-fs-maybe-open-proc (setter fs-maybe-open-proc))
  210.  
  211. (define-operation (set-fs-name fs newname))
  212.  
  213. (define-operation (maybe-open-filename fs filename mode))
  214.  
  215. (define-operation (fs-parse-filespec fs string)
  216.   (make-filename fs nil string nil))
  217.  
  218. (define-predicate file-system?)
  219.  
  220. (define (make-fs fstype names)          ;++ Note internet domain(s) also?
  221.   (let ((name   (car names))
  222.         (access (lambda (fs file mode)
  223.                   (ignore fs)
  224.                   (maybe-open-port file mode))))
  225.     (let ((ln-table (make-table `(logical-names ,name))))
  226.       (let ((fs (object nil
  227.                   ((fs-type self) fstype)
  228.                   ((logical-name self ln)
  229.                    (table-entry ln-table ln))
  230.                   ((set-logical-name self ln def)
  231.                    (set (table-entry ln-table ln) def))
  232.                   ((maybe-open-filename self filename mode)
  233.                    (access self filename mode))
  234.                   ((fs-maybe-open-proc self) access)
  235.                   ((set-fs-maybe-open-proc self val)
  236.                    (set access val))
  237.                   ((fs-name self)
  238.                    (if (null? name) 'anonymous name))
  239.                   ((set-fs-name self newname)
  240.                    (cond ((not (memq? newname names))
  241.                           (push names newname)
  242.                           (set (table-entry fs-table newname) self)
  243.                           (if (null? name) (set name newname)))))
  244.                   ((fs-parse-filespec self string)
  245.                    (parse-filespec fstype self string))
  246.                   ((file-system? self) t)
  247.                   ((print self port)
  248.                    (format port "#{File-system~_~s}" 
  249.                            (fs-name self))))))
  250.         (walk (lambda (name)
  251.                 (set (table-entry fs-table name) fs))
  252.               names)
  253.         fs))))
  254.  
  255.  
  256. ;;; Map file-system names to corresponding file-system-objects.
  257.  
  258. (define fs-table (make-table 'fs-table))
  259.  
  260. (define-predicate filename?)
  261. (define-operation (filename->string filename))
  262. (define-operation (filename-fs   filename))
  263. (define-operation (filename-dir  filename))
  264. (define-operation (filename-leaf filename))
  265. (define-operation (filename-name filename))
  266. (define-operation (filename-type filename))
  267. (define-operation (filename-generation filename))
  268.  
  269.  
  270. ;;; ---------- MAKE-FILENAME
  271.  
  272. (define (make-filename fs ln name . optionals)
  273.   (let ((type (car optionals))
  274.         (gen (cadr optionals))
  275.         (cached-string nil))
  276.     (object nil
  277.             ((maybe-open self mode)
  278.              (maybe-open-filename (->fs fs) self mode))
  279.             ((filename->string self)
  280.              (or cached-string
  281.                  (set cached-string
  282.                       (let ((z (resolve-logical-name (->fs fs)
  283.                                                      ln
  284.                                                      '())))
  285.                         (fs-filename->string (fs-type (car z))
  286.                                              (car z)
  287.                                              (cdr z)
  288.                                              name
  289.                                              type
  290.                                              gen)))))
  291.             ((filename-fs self) fs)
  292.             ((filename-dir self) ln)
  293.             ((filename-leaf self)
  294.              (let ((z (resolve-logical-name (->fs fs) ln '())))
  295.                (fs-filename-leaf (fs-type (car z))
  296.                                  (car z)
  297.                                  name
  298.                                  type
  299.                                  gen)))
  300.             ((filename-name self) name)
  301.             ((filename-type self) type)
  302.             ((filename-generation self) gen)
  303.             ((filename? self) t)
  304.             ((print self port)
  305.              (bind ((*write-symbol* plain-write-symbol))
  306.                (format port "#[Filename~_~S~_~S~_~S"
  307.                        (if (file-system? fs) (fs-name fs) fs) ln name)
  308.                (if (or type gen)
  309.                    (format port "~_~S" type))
  310.                (if gen
  311.                    (format port "~_~S" gen))
  312.                (writec port #\])))
  313.             ((display self port)
  314.              (writes port (filename->string self))))))
  315.  
  316. (define (->fs thing)
  317.   (cond ((null? thing) (local-fs))
  318.         ((and (symbol? thing) (table-entry fs-table thing)))
  319.         ((file-system? thing) thing)
  320.         (else 
  321.          (if (and (neq? thing 'anonymous) (neq? thing 'yale-ring))
  322.              (warning "unknown file system - ~S - using (LOCAL-FS)~%" thing))
  323.          (local-fs))))
  324.  
  325. (define (make-filename-for-read key port rt)
  326.   (ignore key)
  327.   (let* ((l (read-to-right-bracket port #\] rt))
  328.          (n (length l)))
  329.     (cond ((or (fx< n 3) (fx> n 5))
  330.            (read-error port "illegal filename syntax - ~S" l))
  331.           (else
  332.            (apply make-filename l)))))
  333.  
  334. (define (->filename obj)
  335.   (cond ((filename? obj) obj)
  336.         ((string? obj)
  337.          (fs-parse-filespec (local-fs) obj))
  338.         ((symbol? obj)
  339.          (make-filename nil nil obj nil))
  340.         ((and (proper-list? obj)
  341.               (not (null? obj))
  342.               (not (null? (cdr obj))))
  343.          (apply make-filename nil obj))
  344.         (else
  345.          (->filename (error "can't coerce to filename~%  (~S ~S)"
  346.                             '->filename obj)))))
  347.  
  348. (define (filespec? obj)
  349.   (or (filename? obj)
  350.       (string? obj)     ;should check syntax
  351.       (symbol? obj)
  352.       (and (proper-list? obj)
  353.            (not (null? (cdr obj)))      ;(cdr '()) => ()
  354.            (destructure (((dir name type gen . z) obj)) ;(cdr '()) => ()
  355.              (and (null? z)
  356.                   (or (null? dir) (symbol? dir) (string? dir))
  357.                   (or (symbol? name) (string? name))
  358.                   (or (null? type) (symbol? type) (string? type))
  359.                   (or (integer? gen) (null? gen)))))))
  360.  
  361. (define (filename-equal? n1 n2)
  362.   (let ((foo (lambda (x y)
  363.                (or (eq? x y)
  364.                    (and (string? x) (string? y) (string-equal? x y))))))
  365.     (and (eq? (filename-fs   n1) (filename-fs   n2))
  366.          (or (and (foo (filename-dir  n1) (filename-dir  n2))
  367.                   (foo (filename-name n1) (filename-name n2))
  368.                   (foo (filename-type n1) (filename-type n2)))
  369.              (string-equal? (filename->string n1)
  370.                             (filename->string n2))))))
  371.  
  372. ;;; Handy utilities.
  373.  
  374. (define (filename-with-type filename type)
  375.   (make-filename (filename-fs filename)
  376.                  (filename-dir filename)
  377.                  (filename-name filename)
  378.                  type
  379.                  (filename-generation filename)))
  380.  
  381. ;++ how about ->defaulted-filename.
  382. (define (->filename-with-defaults name fs dir . rest)
  383.   (let* ((fname   (expand-filename name))
  384.          (xfs     (filename-fs   fname))
  385.          (xdir    (filename-dir  fname))
  386.          (xname   (filename-name fname))
  387.          (xtype   (filename-type fname))
  388.          (xgen    (filename-generation fname))
  389.          (type    (car rest))
  390.          (gen     (cadr rest)))
  391.     (let ((fs   (if xfs   xfs   fs))
  392.           (dir  (if xdir  xdir  dir))
  393.           (type (if xtype xtype type))
  394.           (gen  (if xgen  xgen  gen)))
  395.       (make-filename fs dir xname type gen))))
  396.  
  397. ;;; ---------- FS-FILENAME->STRING
  398.  
  399. ;;; Synthesize a string naming a given file in file-system-native syntax.
  400.  
  401. (define-operation (fs-filename->string self fs ln name type gen)
  402.   (string-append (namestring-dir-part fs ln)
  403.                  (namestring-name-part fs name)
  404.                  (namestring-type-part fs type)
  405.                  (namestring-gen-part fs gen)))
  406.  
  407. (define-operation (fs-filename-leaf self fs name type gen)
  408.   (string-append (namestring-name-part fs name)
  409.                  (namestring-type-part fs type)
  410.                  (namestring-gen-part fs gen)))
  411.  
  412. ;;; A directory component may be one of:
  413. ;;; - null, for the current working directory;
  414. ;;; - a symbol, for a logical name;
  415. ;;; - a list a component pathnames; or
  416. ;;; - a string, for the actual name of a directory (e.g. "<F.T.X.SYS>").
  417.  
  418. (define-operation (namestring-dir-part fs ln)
  419.   (cond ((null? ln) "")
  420.         ((string? ln)
  421.          (massage-dir-string (fs-type fs) ln))
  422.         ((symbol? ln)
  423.          (massage-logical-name (fs-type fs) ln))
  424.         ((list? ln)
  425.          (massage-dir-pair (fs-type fs) ln))
  426.         (else
  427.          (namestring-dir-part
  428.           fs
  429.           (error "ill-formed directory spec~%  (~S~_~S~_~S~_...)"
  430.                  'filename->string fs ln)))))
  431.  
  432. ;;; The name part may be either a string or a symbol.
  433. ;;; [Note: for VMS, we should probably truncate to 9 characters.]
  434.  
  435. (define (namestring-name-part fs name)
  436.   (cond ((symbol? name)
  437.          (->preferred-case (fs-type fs) (symbol->string name)))
  438.         ((string? name)
  439.          name)
  440.         (else
  441.          (namestring-name-part
  442.           fs
  443.           (error "ill-formed filename spec~%  (~S~_~S~_...~_~S~_...)"
  444.                  'filename->string fs name)))))
  445.  
  446. (define (namestring-type-part fs type)
  447.   (cond ((null? type) "")
  448.         ((symbol? type)
  449.          (let ((fstype (fs-type fs)))
  450.            (string-append "." (->preferred-case fstype (symbol->string type)))))
  451.         ((string? type)
  452.          (string-append "." type))
  453.         (else
  454.          (namestring-type-part
  455.           fs
  456.           (error "ill-formed filename type~%  (~S~_~S~_...~_~S)"
  457.                  'filename->string fs type)))))
  458.  
  459. (define (namestring-gen-part fs gen)
  460.   (cond ((null? gen) "")
  461.         ((and (or (symbol? gen)
  462.                   (fixnum? gen))
  463.               (massage-gen-part (fs-type fs) gen)))
  464.         (else
  465.          (namestring-gen-part
  466.           fs
  467.           (error "ill-formed filename generation~%  (~S~_~S~_...~_~S)"
  468.                  'filename->string fs gen)))))
  469.  
  470. ;;; ---------- Logical names
  471.  
  472. ;;; Logical names internal to T.  The value of a logical name must
  473. ;;; be a pair (file-system . logical-name).  LOGICAL-NAME is a symbol,
  474. ;;; a list, or a search path.
  475.  
  476. (define (resolve-logical-name fs ln circle)
  477.   (let ((z (cons fs ln)))
  478.     (cond ((not (symbol? ln)) z)
  479.           (else
  480.            (cond ((mem? (lambda (x y)
  481.                           (and (eq? (car x) (car y)) (eq? (cdr x) (cdr y))))
  482.                         z
  483.                         circle)
  484.                   ;; Lose!  We've tried to get this one before.
  485.                   (error "circular logical name definitions: ~S" circle))
  486.                  (else
  487.                   (let ((probe (logical-name fs ln)))
  488.                     (cond ((null? probe)
  489.                            ;; Let someone else resolve the logical name.
  490.                            z)
  491.                           ((pair? probe)
  492.                            (resolve-logical-name (car probe)
  493.                                                  (cdr probe)
  494.                                                  (cons z circle)))
  495.                           (else
  496.                            (resolve-logical-name (car z)
  497.                                                  probe
  498.                                                  (cons z circle)))))))))))
  499.  
  500. (set (file-system-present?) '#t)
  501.  
  502. ;;; Local file system
  503.  
  504.  
  505. (define (make-local-fs)
  506.   (let* ((os   (os-type (local-os)))
  507.          (type (cond ((eq? os 'aegis) aegis-fs?)
  508.                      ((eq? os 'unix)  unix-fs?)
  509.                      ((eq? os 'vms)   vms-fs?)
  510.                      (else
  511.                       (error "unknown operating system ~a" os)))))
  512.     (make-fs type '())))
  513.   
  514. (define-simple-switch local-fs 
  515.                       file-system?)
  516.  
  517.  
  518.